home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / src / pl-util.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-26  |  8.9 KB  |  371 lines
  1. /*  $Id: pl-util.c,v 1.19 1997/08/26 10:09:16 jan Exp $
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: asorted handy functions
  8. */
  9.  
  10. #include "pl-incl.h"
  11. #include "pl-ctype.h"
  12.  
  13. static bool    isUserSystemPredicate(Definition def);
  14.  
  15. /*  Return the character representing some digit.
  16.  
  17.  ** Fri Jun 10 10:45:40 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  18.  
  19. char
  20. digitName(int n, bool small)
  21. { if (n <= 9)
  22.     return n + '0';
  23.   return n + (small ? 'a' : 'A') - 10;
  24. }
  25.  
  26. /*  Return the value of a digit when transforming a number of base 'b'.
  27.     Return '-1' if it is an illegal digit.
  28.  
  29.  ** Fri Jun 10 10:46:40 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  30.  
  31. int
  32. digitValue(int b, int c)
  33. { int v;
  34.  
  35.   if ( b == 0 )
  36.     return c;                /* 0'c */
  37.   if ( b == 1 )
  38.     return -1;
  39.   if ( b <= 10 )
  40.   { v = c - '0';
  41.     if ( v < b )
  42.       return v;
  43.     return -1;
  44.   }
  45.   if ( c <= '9' )
  46.     return c - '0';
  47.   if (isUpper(c))
  48.     c = toLower(c);
  49.   c = c - 'a' + 10;
  50.   if ( c < b && c >= 10 )
  51.     return c;
  52.   return -1;
  53. }
  54.  
  55.  
  56. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  57. These  functions  return  a  user-printable  name   of  a  predicate  as
  58. name/arity or module:name/arity. The result  is   stored  in the foreign
  59. buffer ring, so we are thread-safe, but   the  result needs to be copied
  60. before the ring is exhausted. See buffer_string() for details.
  61. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  62.  
  63. char *
  64. procedureName(Procedure proc)
  65. { return predicateName(proc->definition);
  66. }
  67.  
  68.  
  69. char *
  70. predicateName(Definition def)
  71. { char tmp[256];
  72.  
  73.   if ( def->module == MODULE_user || isUserSystemPredicate(def) )
  74.     Ssprintf(tmp, "%s/%d",
  75.          stringAtom(def->functor->name), 
  76.          def->functor->arity);
  77.   else
  78.     Ssprintf(tmp, "%s:%s/%d",
  79.          stringAtom(def->module->name), 
  80.          stringAtom(def->functor->name), 
  81.          def->functor->arity);
  82.  
  83.   return buffer_string(tmp, BUF_RING);
  84. }
  85.  
  86. /*  succeeds if proc is a system predicate exported to the public module.
  87.  
  88.  ** Fri Sep  2 17:03:43 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  89.  
  90. static bool
  91. isUserSystemPredicate(Definition def)
  92. { if ( true(def, SYSTEM) &&
  93.        isCurrentProcedure(def->functor->functor, MODULE_user) )
  94.     succeed;
  95.  
  96.   fail;
  97. }
  98.  
  99. word
  100. notImplemented(char *name, int arity)
  101. { return warning("%s/%d is not implemented in this version", name, arity);
  102. }
  103.  
  104. word
  105. setBoolean(int *flag, const char *name, term_t old, term_t new)
  106. { atom_t n;
  107.  
  108.   if ( !PL_unify_atom(old, *flag ? ATOM_on : ATOM_off) )
  109.     fail;
  110.  
  111.   if ( PL_get_atom(new, &n) )
  112.   { if ( n == ATOM_on )
  113.     { *flag = TRUE;
  114.       succeed;
  115.     } else if ( n == ATOM_off )
  116.     { *flag = FALSE;
  117.       succeed;
  118.     }
  119.   }
  120.  
  121.   return warning("%s/2: instantiation fault", name);
  122. }
  123.  
  124. word
  125. setInteger(int *flag, const char *name, term_t old, term_t new)
  126. { if ( !PL_unify_integer(old, *flag) )
  127.     fail;
  128.   if ( PL_get_integer(new, flag) )
  129.     succeed;
  130.  
  131.   return warning("%s/2: instantiation fault", name);
  132. }
  133.  
  134.  
  135. word
  136. setLong(long *flag, const char *name, term_t old, term_t new)
  137. { if ( !PL_unify_integer(old, *flag) )
  138.     fail;
  139.   if ( PL_get_long(new, flag) )
  140.     succeed;
  141.  
  142.   return warning("%s: instantiation fault", name);
  143. }
  144.  
  145.  
  146.          /*******************************
  147.          *           OPTIONS        *
  148.          *******************************/
  149.  
  150. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  151. Variable argument list:
  152.  
  153.     atom_t    name
  154.     int    type    OPT_ATOM, OPT_STRING, OPT_BOOL, OPT_INT
  155.     pointer    value
  156. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  157.  
  158. #define MAXOPTIONS 32
  159.  
  160. typedef union
  161. { bool *b;                /* boolean value */
  162.   long *i;                /* integer value */
  163.   char **s;                /* string value */
  164.   word *a;                /* atom value */
  165.   term_t *t;                /* term-reference */
  166.   void *ptr;                /* anonymous pointer */
  167. } optvalue;
  168.  
  169. bool
  170. scan_options(term_t options, int flags, atom_t optype,
  171.          const opt_spec *specs, ...)
  172. { va_list args;
  173.   const opt_spec *s;
  174.   optvalue values[MAXOPTIONS];
  175.   term_t list = PL_copy_term_ref(options);
  176.   term_t head = PL_new_term_ref();
  177.   term_t tmp  = PL_new_term_ref();
  178.   term_t val  = PL_new_term_ref();
  179.   int n;
  180.  
  181.   va_start(args, specs);
  182.   for( n=0, s = specs; s->name; s++, n++ )
  183.     values[n].ptr = va_arg(args, void *);
  184.   va_end(args);
  185.  
  186.   while ( PL_get_list(list, head, list) )
  187.   { atom_t name;
  188.     int arity;
  189.     
  190.     if ( PL_get_name_arity(head, &name, &arity) )
  191.     { if ( name == ATOM_equals && arity == 2 )
  192.       { PL_get_arg(1, head, tmp);
  193.  
  194.     if ( !PL_get_atom(tmp, &name) )
  195.       goto itemerror;
  196.     PL_get_arg(2, head, val);
  197.       } else if ( arity == 1 )
  198.       { PL_get_arg(1, head, val);
  199.       } else if ( arity == 0 )
  200.     PL_put_atom(val, ATOM_true);
  201.     } else if ( PL_is_variable(head) )
  202.     { return PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
  203.     } else
  204.     { itemerror:
  205.       return PL_error(NULL, 0, NULL, ERR_DOMAIN, optype, head);
  206.     }
  207.  
  208.     for( n=0, s = specs; s->name; n++, s++ )
  209.     { if ( s->name == name )
  210.       { switch(s->type)
  211.     { case OPT_BOOL:
  212.       { atom_t aval;
  213.  
  214.         if ( !PL_get_atom(val, &aval) )
  215.           fail;
  216.         if ( aval == ATOM_true || aval == ATOM_on )
  217.           *values[n].b = TRUE;
  218.         else if ( aval == ATOM_false || aval == ATOM_off )
  219.           *values[n].b = FALSE;
  220.         else
  221.           goto itemerror;
  222.         break;
  223.       }
  224.       case OPT_INT:
  225.       { if ( !PL_get_long(val, values[n].i) )
  226.           goto itemerror;
  227.  
  228.         break;
  229.       }
  230.       case OPT_STRING:
  231.       { char *str;
  232.  
  233.         if ( !PL_get_chars(val, &str, CVT_ALL) ) /* copy? */
  234.           goto itemerror;
  235.         *values[n].s = str;
  236.         break;
  237.       }
  238.       case OPT_ATOM:
  239.       { atom_t a;
  240.  
  241.         if ( !PL_get_atom(val, &a) )
  242.           goto itemerror;
  243.         *values[n].a = a;
  244.         break;
  245.       }
  246.       case OPT_TERM:
  247.       { *values[n].t = val;
  248.         val = PL_new_term_ref();    /* can't reuse anymore */
  249.         break;
  250.       }
  251.       default:
  252.         assert(0);
  253.         fail;
  254.     }
  255.       }
  256.     }
  257.     
  258.     if ( !s->name && (flags & OPT_ALL) )
  259.       goto itemerror;
  260.   }
  261.  
  262.   if ( !PL_get_nil(list) )
  263.     return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, options);
  264.   
  265.   succeed;
  266. }
  267.  
  268.  
  269.  
  270.         /********************************
  271.         *             STRING            *
  272.         *********************************/
  273.  
  274.  
  275. bool
  276. strprefix(register char *string, register char *prefix)
  277. { while(*prefix && *string == *prefix)
  278.     prefix++, string++;
  279.   if (*prefix == EOS )
  280.     succeed;
  281.   fail;
  282. }
  283.  
  284.  
  285. bool
  286. strpostfix(char *string, char *postfix)
  287. { long offset = strlen(string) - strlen(postfix);
  288.  
  289.   if ( offset < 0 )
  290.     fail;
  291.  
  292.   return streq(&string[offset], postfix);
  293. }
  294.  
  295.  
  296. #ifndef HAVE_STRICMP
  297. int
  298. stricmp(const char *s1, const char *s2)
  299. { while(*s1 && makeLower(*s1) == makeLower(*s2))
  300.     s1++, s2++;
  301.   
  302.   return makeLower(*s1) - makeLower(*s2);
  303. }
  304. #endif
  305.  
  306. #ifndef HAVE_STRLWR
  307. char *
  308. strlwr(char *s)
  309. { char *q;
  310.  
  311.   for(q=s; *q; q++)
  312.     *q = makeLower(*q);
  313.  
  314.   return s;
  315. }
  316. #endif
  317.  
  318.  
  319. bool
  320. stripostfix(const char *s, const char *e)
  321. { int ls = strlen(s);
  322.   int le = strlen(e);
  323.  
  324.   if ( ls >= le )
  325.     return stricmp(&s[ls-le], e) == 0;
  326.  
  327.   return FALSE;
  328. } 
  329.  
  330.  
  331.         /********************************
  332.         *        CHARACTER TYPES        *
  333.         *********************************/
  334.  
  335. char _PL_char_types[] = {
  336. /* ^@  ^A  ^B  ^C  ^D  ^E  ^F  ^G  ^H  ^I  ^J  ^K  ^L  ^M  ^N  ^O    0-15 */
  337.    SP, SP, SP, SP, SP, SP, SP, SP, SP, SP, SP, SP, SP, SP, SP, SP, 
  338. /* ^P  ^Q  ^R  ^S  ^T  ^U  ^V  ^W  ^X  ^Y  ^Z  ^[  ^\  ^]  ^^  ^_   16-31 */
  339.    SP, SP, SP, SP, SP, SP, SP, SP, SP, SP, SP, SP, SP, SP, SP, SP, 
  340. /* sp   !   "   #   $   %   &   '   (   )   *   +   ,   -   .   /   32-47 */
  341.    SP, SO, DQ, SY, SY, SO, SY, SQ, PU, PU, SY, SY, PU, SY, SY, SY, 
  342. /*  0   1   2   3   4   5   6   7   8   9   :   ;   <   =   >   ?   48-63 */
  343.    DI, DI, DI, DI, DI, DI, DI, DI, DI, DI, SY, SO, SY, SY, SY, SY, 
  344. /*  @   A   B   C   D   E   F   G   H   I   J   K   L   M   N   O   64-79 */
  345.    SY, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, 
  346. /*  P   Q   R   S   T   U   V   W   X   Y   Z   [   \   ]   ^   _   80-95 */
  347.    UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, UC, PU, SY, PU, SY, UC, 
  348. /*  `   a   b   c   d   e   f   g   h   i   j   k   l   m   n   o   96-111 */
  349.    SY, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, 
  350. /*  p   q   r   s   t   u   v   w   x   y   z   {   |   }   ~  ^?   112-127 */
  351.    LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, PU, PU, PU, SY, SP, 
  352.               /* 128-255 */
  353.    LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, 
  354.    LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, 
  355.    LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, 
  356.    LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, 
  357.    LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, 
  358.    LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, 
  359.    LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, 
  360.    LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC, LC };
  361.  
  362. void
  363. systemMode(bool accept)
  364. { _PL_char_types[(int)'$'] = (accept ? LC : SY);
  365.   if ( accept )
  366.     debugstatus.styleCheck |= DOLLAR_STYLE;
  367.   else
  368.     debugstatus.styleCheck &= ~DOLLAR_STYLE;
  369. }
  370.  
  371.